home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
PBLIB1
/
PROGS
/
BFILEGEN.PAS
next >
Wrap
Pascal/Delphi Source File
|
1994-05-03
|
9KB
|
329 lines
Program BFILEGen;
{$M 10000,0,10000}
uses PbMISC, PbDATA, PbOBJS, PbPARMS;
{
Description: Program to generate PASCAL Type for BFILE record
Author : Howard Richoux
Date : 10/10/90
Last revised: 1/19/94 hnr 1.00 started from dbpasgen
2/18/94 hnr 1.02 new libraries
Application : IBM PC and compatibles, done in Turbo Pascal 5.0
Status : Placed in the Public Domain by HNR Software 1/29/94
Published in: none
}
var bfilename : string[40];
var recname : string[7];
var L : OUT_object_0;
var DDL : HOLD_object;
FieldSpec : string; { FIELDS=[fld1(c10),fld2(i)...] }
Function DDLRecSize(var Fl : hold_object) : longint;
var i,j : integer;
begin
j := 0;
for i := 1 to DDL.count do j := j + DDL.fetchNumN(i);
DDLRecSize := j;
end;
Procedure DDLPasFields(var Fl : hold_object);
var i,j,len : integer;
s, nam,typstr : string;
typ : char;
begin
for j := 1 to DDL.count do
begin
nam := UpCaseStr(Fl.fetchStrN(j));
s := GetDelimitedStr(nam,'(',')');
typ := s[1];
typstr := '';
case typ of
'I' : typstr := 'integer;'; {integer}
'L' : typstr := 'longint;'; {longint}
'R' : typstr := 'real;'; {real}
'C' : begin {char array}
len := GetInteger(s);
if len = 0 then len := 1;
if len > 1 then
typstr := 'array[1..'+integerstr(len,3)+'] of char;'
else typstr := 'char;';
end;
else begin {unknown}
typstr := '{Unknown field type ['+typ+']}';
len := 0;
end;
end;
L.out(' '+leftstr(nam,10)+': '+typstr);
end;
end;
Procedure LoadDDL(var recroot : string);
var i,j : integer;
s, s1,s2,s3 : string;
begin
writeln('-------');
writeln('{FIELDS='+FieldSpec+'}');
DDL.init(50);
s := RemoveBrackets(FieldSpec);
writeln('{FIELDS='+s+'}');
while length(s) > 0 do
begin
s1 := GetLeftStr(s,',');
s3 := s1; {keep it}
s2 := UpCaseStr(GetDelimitedStr(s1,'(',')'));
case s2[1] of
'I' : i := 2; {integer}
'L' : i := 4; {longint}
'R' : i := 4; {real}
'C' : begin {char array}
i := GetInteger(s2); {keep this}
if i = 0 then i := 1;
end;
else begin
writeln('Unknown field type [',s2[1],']');
i := 0;
end;
end;
DDL.append(s3,i);
end;
writeln('-------');
DDL.dump;
writeln(' Total length ',DDLRecSize(DDL));
writeln('-------');
end;
Procedure MakeUnit(RecRoot : string);
var i, width : integer;
rtype : char;
tmp, tpe : string[40];
begin
L.out('{SECTION ..B'+RecRoot+' }');
L.out(' ');
L.out('{ '+pProgID+' - hnr '+FormatDTime+
', Placed in the Public Domain by HNR Software 1/94 }');
L.out(' ');
L.out('Unit b'+RecRoot+';');
L.out(' ');
L.out('INTERFACE');
L.out(' ');
L.out('Uses PbMISC, PbOBJS;');
L.out(' ');
end;
Procedure MakeUnitEnd;
begin
L.out(' ');
L.out('{SECTION zzInitialization }');
L.out(' begin { initialization }');
L.out(' end.');
end;
Procedure MakeObject(RecRoot : string);
var i, width : integer;
rtype : char;
tmp, tpe : string[40];
begin
L.out('{SECTION .'+RecRoot+'_BFILE_object }');
L.out(' ');
L.out('const '+RecRoot+'_recsize = '+
integerstr(DDLRecSize(DDL),4)+';');
L.out(' ');
L.out('const '+RecRoot+'_filename = '''+bfilename+''';');
L.out(' ');
L.out('type '+RecRoot+'_BFILE_object = OBJECT(BFILE_object)');
L.out(' rec : '+RecRoot+'_record;');
L.out(' Procedure init ( fn : string; fmode : integer);');
L.out(' Function ReadRec ( i : longint) : boolean;');
L.out(' Function WriteRec ( i : longint) : boolean;');
L.out(' Function ReadNextRec : boolean;');
L.out(' Function AppendRec : boolean;');
L.out(' end;');
L.out(' ');
L.out('{SECTION .zImplementation }');
L.out('IMPLEMENTATION');
L.out(' ');
end;
Procedure MakeInitProc(RecRoot : string);
var i, width : integer;
rtype : char;
tmp,tmp2,tpe : string[20];
begin
L.out(' ');
L.out('Procedure '+RecRoot+'_BFILE_object.Init(fn : string; fmode : integer);');
L.out(' begin');
L.out(' BFILE_object.init(fn,'+RecRoot+'_recsize,fmode);');
L.out(' end;');
L.out(' ');
L.out(' ');
end;
Procedure MakeRecType(RecRoot : string);
var i, width : integer;
rtype : char;
tmp, tpe : string;
begin
L.out('{SECTION .'+RecRoot+'_record }');
L.out('type '+RecRoot+'_record = record ');
DDLPasFields(DDL);
L.OUT(' end;');
L.out(' ');
end;
Procedure MakeReadWriteProcs(RecRoot : string);
var i, width : integer;
rtype : char;
tmp,tmp2,tpe : string[20];
begin
L.out(' ');
L.out('Function '+RecRoot+'_BFILE_object.ReadRec( i : longint) : boolean;');
L.OUT(' begin');
L.OUT(' ReadRec := true;');
L.OUT(' if not BFILE_object.fetchN(i,rec) then ');
L.OUT(' begin');
L.OUT(' ReadRec := false;');
L.OUT(' fillchar(rec,sizeof(rec),0);');
L.OUT(' end;');
L.OUT(' end;');
L.out(' ');
L.out(' ');
L.out('Function '+RecRoot+'_BFILE_object.WriteRec( i : longint) : boolean;');
L.out(' begin');
L.out(' WriteRec := true;');
L.OUT(' if not BFILE_object.storeN(i,rec) then ');
L.OUT(' begin');
L.OUT(' WriteRec := false;');
L.OUT(' end;');
L.out(' end;');
L.out(' ');
L.out(' ');
L.out('Function '+RecRoot+'_BFILE_object.ReadNextRec : boolean;');
L.OUT('var n : longint;');
L.OUT(' begin');
L.OUT(' ReadNextRec := true;');
L.OUT(' n := curr+1;');
L.OUT(' if not BFILE_object.fetchN(n,rec) then ');
L.OUT(' begin');
L.OUT(' ReadNextRec := false;');
L.OUT(' fillchar(rec,sizeof(rec),0);');
L.OUT(' end;');
L.OUT(' end;');
L.out(' ');
L.out(' ');
L.out('Function '+RecRoot+'_BFILE_object.AppendRec : boolean;');
L.OUT('var n : longint;');
L.OUT(' begin');
L.out(' AppendRec := true;');
L.OUT(' n := curr+1;');
L.OUT(' if not BFILE_object.storeN(n,rec) then ');
L.OUT(' begin');
L.OUT(' AppendRec := false;');
L.OUT(' end;');
L.out(' end;');
L.out(' ');
L.out(' ');
L.out(' ');
end;
Function MakeRoot(path : string) : string;
var s : string;
i : integer;
begin
s := path;
i := pos('\',s);
while i > 0 do
begin
delete(s,1,i);
i := pos('\',s);
end;
i := pos('.',s);
if i > 1 then s := leftstr(s,i-1);
Makeroot := s;
end;
Procedure MakePas(RecRoot : string);
var outfname : string[40];
begin
getdir(0,outfname);
outfname := addbackslash(outfname) + 'b' + RecRoot;
forceext(outfname,'pas');
writeln('writing to ',outfname);
L.LISTinit(outfname,OUT_typREWRITE);
L.LISTopen;
MakeUnit(RecRoot);
MakeRecType(RecRoot);
MakeObject(RecRoot);
MakeInitProc(RecRoot);
MakeReadWriteProcs(RecRoot);
MakeUnitEnd;
L.done;
end;
Procedure DoBFILEGen(bfilename : string);
var fn : string[40];
i : integer;
RecRoot : string[8];
begin
fn := bfilename;
ForceExt(fn,'dbf');
writeln('fn ',fn);
if recname = '' then RecRoot := UpCaseStr(MakeRoot(fn))
else RecRoot := UpCaseStr(recname);
writeln('record name= ',RecRoot);
LoadDDL(RecRoot);
MakePas(RecRoot);
end;
Procedure BFILEGenInit;
begin
recname := '';
bfilename := '';
addparm(1,'REC','');
addparm(1,'FILE','');
addparm(1,'FIELDS','');
StandardpVarsInit;
bfilename := GetParmStr('FILE');
FieldSpec := GetParmSTr('FIELDS');
recname := GetParmSTr('REC');
if paramcount > 0 then bfilename := paramstr(1);
end;
begin
pProgID := 'BFILEGen 1.02';
BFILEGenInit;
if FieldSpec <> '' then
begin
DoBFILEGen(bfilename);
end
else writeln('Without specifying a FIELDS= list, there is no point in this exercise');
writeln('');
end.